home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASWIZ20 / ARCHIVES.PAS < prev    next >
Pascal/Delphi Source File  |  1994-11-04  |  16KB  |  545 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1994  Thomas G. Hanlin III         |
  4.     |                                                                      |
  5.     +----------------------------------------------------------------------+
  6.  
  7.  
  8.  
  9. Archives:
  10.  
  11.    This collection of routines allows you to retrieve full directory
  12.    information from any popular archive format: ARC, ARJ, LZH, PAK, ZIP,
  13.    ZOO, or even self-extracting .EXEs.
  14.  
  15. }
  16.  
  17.  
  18.  
  19. UNIT Archives;
  20.  
  21.  
  22.  
  23. INTERFACE
  24.  
  25.  
  26.  
  27. PROCEDURE CloseA;
  28. FUNCTION GetCRCA: STRING;
  29. FUNCTION GetDateA: STRING;
  30. FUNCTION GetNameA: STRING;
  31. PROCEDURE GetSizeA (VAR OriginalSize: LONGINT; VAR CurrentSize: LONGINT);
  32. FUNCTION GetStoreA: STRING;
  33. FUNCTION GetTimeA: STRING;
  34. PROCEDURE FindNextA (VAR ErrCode: INTEGER);
  35. PROCEDURE FindFirstA (Archive, FileName: STRING; VAR ErrCode: INTEGER);
  36.  
  37.  
  38.  
  39. { --------------------------------------------------------------------------- }
  40.  
  41.  
  42.  
  43. IMPLEMENTATION
  44.  
  45. USES
  46.    Strings;
  47.  
  48.  
  49.  
  50. TYPE
  51.    BufferType = RECORD
  52.       CASE banana: BOOLEAN OF
  53.          FALSE: (junk: CHAR; buf: ARRAY[1..127] OF CHAR);
  54.          TRUE : (str: STRING[128]);
  55.    END;
  56.  
  57.  
  58.  
  59. VAR
  60.    ArcType:
  61.       INTEGER;
  62.    Handle:
  63.       FILE;
  64.    PatternFileName:
  65.       STRING;
  66.    Header:
  67.       BufferType;
  68.  
  69.  
  70.  
  71. FUNCTION StrF (x: WORD): STRING;
  72. VAR
  73.    st: STRING;
  74. BEGIN
  75.    Str(x, st);
  76.    StrF := st;
  77. END;
  78.  
  79.  
  80.  
  81. FUNCTION CVI (st: STRING): INTEGER;
  82. BEGIN
  83.    CVI := ORD(st[2]) SHL 8 + ORD(St[1]);
  84. END;
  85.  
  86.  
  87.  
  88. FUNCTION CVL (st: STRING): LONGINT;
  89. BEGIN
  90.    CVL := (ORD(st[4]) SHL 8 + ORD(St[3]) SHL 16)
  91.         + ORD(st[2]) SHL 8 + ORD(St[1]);
  92. END;
  93.  
  94.  
  95.  
  96. PROCEDURE CloseA;
  97. BEGIN
  98.    Close(Handle);
  99. END;
  100.  
  101.  
  102.  
  103. FUNCTION FileExists(FileName: STRING): BOOLEAN;
  104. VAR
  105.    Handle: FILE;
  106. BEGIN
  107.    {$I-}
  108.    Assign(Handle, FileName);
  109.    Reset(Handle);
  110.    Close(Handle);
  111.    {$I+}
  112.    FileExists := (IOResult = 0);
  113. END;
  114.  
  115.  
  116.  
  117. FUNCTION GetCRCA: STRING;
  118. VAR
  119.    CRC, Result: STRING;
  120.    tmp, Digit: WORD;
  121. BEGIN
  122.    CASE ArcType OF
  123.       1: CRC := Copy(Header.str, 24, 2) + CHR(0) + CHR(0);
  124.       2: CRC := Copy(Header.str, ORD(Header.str[22]) + 23, 2) + CHR(0) + CHR(0);
  125.       3: CRC := Copy(Header.str, 15, 4);
  126.       4: CRC := Copy(Header.str, 19, 2) + CHR(0) + CHR(0);
  127.       5: CRC := Copy(Header.str, 25, 4);
  128.    END;
  129.    CRC := CRC[4] + CRC[3] + CRC[2] + CRC[1];
  130.    Result := '';
  131.    FOR tmp := 1 TO 4 DO BEGIN
  132.       Digit := ORD(CRC[tmp]) SHR 4;
  133.       IF Digit < 10 THEN
  134.          Result := Result + CHR(Digit + 48)
  135.       ELSE
  136.          Result := Result + CHR(Digit + 55);
  137.       Digit := ORD(CRC[tmp]) AND $F;
  138.       IF Digit < 10 THEN
  139.          Result := Result + CHR(Digit + 48)
  140.       ELSE
  141.          Result := Result + CHR(Digit + 55);
  142.    END;
  143.    GetCRCA := Result;
  144. END;
  145.  
  146.  
  147.  
  148. FUNCTION GetDateA: STRING;
  149. VAR
  150.    Year, Month, Day: STRING;
  151.    tmp: LONGINT;
  152. BEGIN
  153.    CASE ArcType OF
  154.       1: tmp := CVL(Copy(Header.str, 20, 2) + CHR(0) + CHR(0));
  155.       2: tmp := CVL(Copy(Header.str, 18, 2) + CHR(0) + CHR(0));
  156.       3: tmp := CVL(Copy(Header.str, 13, 2) + CHR(0) + CHR(0));
  157.       4: tmp := CVL(Copy(Header.str, 15, 2) + CHR(0) + CHR(0));
  158.       5: tmp := CVL(Copy(Header.str, 15, 2) + CHR(0) + CHR(0));
  159.    END;
  160.    Year := Right('000' + StrF(tmp DIV 512 + 1980), 4);
  161.    Day := Right('0' + StrF(tmp AND $1F), 2);
  162.    Month := Right('0' + StrF(tmp DIV 32 AND $F), 2);
  163.    GetDateA := Month + '-' + Day + '-' + Year;
  164. END;
  165.  
  166.  
  167.  
  168. FUNCTION GetNameA: STRING;
  169. VAR
  170.    FileName, St: STRING;
  171.    FLen: WORD;
  172. BEGIN
  173.    CASE ArcType OF
  174.       1: BEGIN
  175.             St := Copy(Header.str, 3, 13);
  176.             FLen := Pos(CHR(0), St);
  177.             IF FLen = 0 THEN
  178.                FLen := 12
  179.             ELSE
  180.                DEC(FLen);
  181.             FileName := St;
  182.          END;
  183.       2: BEGIN
  184.             FLen := ORD(Header.str[22]);
  185.             FileName := Copy(Header.str, 23, FLen);
  186.          END;
  187.       3: BEGIN
  188.             FLen := ORD(Header.str[27]);
  189.             FileName := Copy(Header.str, 31, FLen);
  190.          END;
  191.       4: IF Header.str[31] = CHR(1) THEN
  192.             FLen := 0
  193.          ELSE BEGIN
  194.             FLen := Pos(CHR(0), Copy(Header.str, 39, 13)) - 1;
  195.             FileName := Copy(Header.str, 39, FLen);
  196.          END;
  197.       5: IF ORD(Header.str[11]) > 1 THEN
  198.             FLen := 0
  199.          ELSE BEGIN
  200.             St := Copy(Header.str, 35, 80);
  201.             Flen := Pos(CHR(0), St);
  202.             IF FLen > 0 THEN DEC(FLen);
  203.             FileName := St;
  204.          END;
  205.    END;
  206.    GetNameA := Copy(FileName, 1, FLen);
  207. END;
  208.  
  209.  
  210.  
  211. PROCEDURE GetSizeA (VAR OriginalSize: LONGINT; VAR CurrentSize: LONGINT);
  212. BEGIN
  213.    CASE ArcType OF
  214.       1: BEGIN
  215.             CurrentSize := CVL(Copy(Header.str, 16, 4));
  216.             IF ORD(Header.str[2]) = 1 THEN
  217.                OriginalSize := CurrentSize
  218.             ELSE
  219.                OriginalSize := CVL(Copy(Header.str, 26, 4));
  220.          END;
  221.       2: BEGIN
  222.             OriginalSize := CVL(Copy(Header.str, 12, 4));
  223.             CurrentSize := CVL(Copy(Header.str, 8, 4));
  224.          END;
  225.       3: BEGIN
  226.             OriginalSize := CVL(Copy(Header.str, 23, 4));
  227.             CurrentSize := CVL(Copy(Header.str, 19, 4));
  228.          END;
  229.       4: BEGIN
  230.             OriginalSize := CVL(Copy(Header.str, 21, 4));
  231.             CurrentSize := CVL(Copy(Header.str, 25, 4));
  232.          END;
  233.       5: BEGIN
  234.             OriginalSize := CVL(Copy(Header.str, 21, 4));
  235.             CurrentSize := CVL(Copy(Header.str, 17, 4));
  236.          END;
  237.    END;
  238. END;
  239.  
  240.  
  241.  
  242. FUNCTION GetStoreA: STRING;
  243. BEGIN
  244.    CASE ArcType OF
  245.       1: CASE ORD(Header.str[2]) OF
  246.             1, 2: GetStoreA := 'Stored';
  247.             3: GetStoreA := 'Packed';
  248.             4: GetStoreA := 'Squeezed';
  249.             5, 6: GetStoreA := 'crunched';
  250.             7, 8: GetStoreA := 'Crunched';
  251.             9: GetStoreA := 'Squashed';
  252.             10: GetStoreA := 'Crushed';
  253.             11: GetStoreA := 'Distill';
  254.             ELSE GetStoreA := '';
  255.          END;
  256.       2: GetStoreA := RTrim(Copy(Header.str, 3, 5));
  257.       3: CASE ORD(Header.str[9]) OF
  258.             0: GetStoreA := 'Stored';
  259.             1: GetStoreA := 'Shrunk';
  260.             2: GetStoreA := 'Reduce-1';
  261.             3: GetStoreA := 'Reduce-2';
  262.             4: GetStoreA := 'Reduce-3';
  263.             5: GetStoreA := 'Reduce-4';
  264.             6: GetStoreA := 'Imploded';
  265.             8: GetStoreA := 'Deflated';
  266.             ELSE GetStoreA := '';
  267.          END;
  268.       4: GetStoreA := '';
  269.       5: GetStoreA := CHR(ORD(Header.str[10]) + 48);
  270.    END;
  271. END;
  272.  
  273.  
  274.  
  275. FUNCTION GetTimeA: STRING;
  276. VAR
  277.    tmp: LONGINT;
  278.    Hour, Second, Minute: STRING;
  279. BEGIN
  280.    CASE ArcType OF
  281.       1: tmp := CVL(Copy(Header.str, 22, 2) + CHR(0) + CHR(0));
  282.       2: tmp := CVL(Copy(Header.str, 16, 2) + CHR(0) + CHR(0));
  283.       3: tmp := CVL(Copy(Header.str, 11, 2) + CHR(0) + CHR(0));
  284.       4: tmp := CVL(Copy(Header.str, 17, 2) + CHR(0) + CHR(0));
  285.       5: tmp := CVL(Copy(Header.str, 13, 2) + CHR(0) + CHR(0));
  286.    END;
  287.    Hour := Right('0' + StrF(tmp DIV 2048), 2);
  288.    Second := Right('0' + StrF((tmp AND $1F) * 2), 2);
  289.    Minute := Right('0' + StrF((tmp DIV 32) AND $3F), 2);
  290.    GetTimeA := Hour + ':' + Minute + ':' + Second;
  291. END;
  292.  
  293.  
  294.  
  295. PROCEDURE FindNextA (VAR ErrCode: INTEGER);
  296. VAR
  297.    CurFileName: STRING;
  298.    Found: BOOLEAN;
  299.    Chars, Posn: WORD;
  300. BEGIN
  301.    Found := FALSE;
  302.    WHILE NOT Found AND (ErrCode = 0) DO BEGIN
  303.       Posn := FilePos(Handle);
  304.       CASE ArcType OF
  305.          1: BEGIN
  306.                IF ORD(Header.str[2]) = 1 THEN
  307.                   INC(Posn, 25)
  308.                ELSE
  309.                   INC(Posn, 29);
  310.                INC(Posn, CVL(Copy(Header.str, 16, 4)));
  311.             END;
  312.          2: INC(Posn, LONGINT(ORD(Header.str[1])) + 2
  313.                       + CVL(Copy(Header.str, 8, 4)));
  314.          3: INC(Posn, 30 + LONGINT(CVI(Copy(Header.str, 27, 2)))
  315.                       + LONGINT(CVI(Copy(Header.str, 29, 2)))
  316.                       + CVL(Copy(Header.str, 19, 4)));
  317.          4: Posn := CVL(Copy(Header.str, 7, 4));
  318.          5: INC(Posn, LONGINT(CVI(Copy(Header.str, 3, 2)))
  319.                       + CVL(Copy(Header.str, 17, 4)) + 10);
  320.       END;
  321.       IF ErrCode = 0 THEN BEGIN
  322.          Seek(Handle, Posn);
  323.          ErrCode := IOResult;
  324.       END;
  325.       IF ErrCode = 0 THEN BEGIN
  326.          BlockRead(Handle, Header.buf, 128, Chars);
  327.          Header.str[0] := CHR(Chars);
  328.          ErrCode := IOResult;
  329.       END;
  330.       CASE ArcType OF
  331.          1: IF (ORD(Header.str[1]) <> 26) OR (ORD(Header.str[2]) = 0) THEN
  332.                ErrCode := 9999;
  333.          2: IF (Header.str[3] <> '-') OR (ORD(Header.str[1]) = 0) THEN
  334.                ErrCode := 9999;
  335.          3: IF Copy(Header.str, 1, 4) <> 'PK' + CHR(3) + CHR(4) THEN
  336.                ErrCode := 9999;
  337.          5: IF (Copy(Header.str, 1, 2) <> CHR($60) + CHR($EA)) OR (CVI(Copy(Header.str, 3, 2)) = 0) THEN
  338.                ErrCode := 9999;
  339.          ELSE ;
  340.       END;
  341.       IF ErrCode = 0 THEN BEGIN
  342.          Seek(Handle, Posn);
  343.          ErrCode := IOResult;
  344.       END;
  345.       IF ErrCode = 0 THEN BEGIN
  346.          CurFileName := GetNameA;
  347.          IF Length(CurFileName) > 0 THEN
  348.             Found := MatchFile(PatternFileName, CurFileName)
  349.          ELSE
  350.             Found := FALSE;
  351.       END;
  352.    END;
  353. END;
  354.  
  355.  
  356.  
  357. PROCEDURE FindFirstA (Archive, FileName: STRING; VAR ErrCode: INTEGER);
  358. VAR
  359.    CurFileName, St: STRING;
  360.    Posn: LONGINT;
  361.    Found: BOOLEAN;
  362.    Chars: WORD;
  363. BEGIN
  364.    ErrCode := 0;
  365.    Archive := UpperCase(Archive);
  366.    PatternFileName := UpperCase(FileName);
  367.  
  368.    IF Pos('.', Archive) = 0 THEN
  369.       IF FileExists(Archive + '.ZIP') THEN
  370.          Archive := Archive + '.ZIP'
  371.       ELSE IF FileExists(Archive + '.LZH') THEN
  372.          Archive := Archive + '.LZH'
  373.       ELSE IF FileExists(Archive + '.ARC') THEN
  374.          Archive := Archive + '.ARC'
  375.       ELSE IF FileExists(Archive + '.PAK') THEN
  376.          Archive := Archive + '.PAK'
  377.       ELSE IF FileExists(Archive + '.ZOO') THEN
  378.          Archive := Archive + '.ZOO'
  379.       ELSE IF FileExists(Archive + '.ARJ') THEN
  380.          Archive := Archive + '.ARJ'
  381.       ELSE IF FileExists(Archive + '.EXE') THEN
  382.          Archive := Archive + '.EXE'
  383.       ELSE IF FileExists(Archive + '.COM') THEN
  384.          Archive := Archive + '.COM'
  385.       ELSE
  386.          Archive := Archive + '.';
  387.  
  388.    St := Right(Archive, 3);
  389.    IF (St = 'ARC') OR (St = 'PAK') THEN
  390.       ArcType := 1
  391.    ELSE IF St = 'LZH' THEN
  392.       ArcType := 2
  393.    ELSE IF St = 'ZIP' THEN
  394.       ArcType := 3
  395.    ELSE IF St = 'ZOO' THEN
  396.       ArcType := 4
  397.    ELSE IF St = 'ARJ' THEN
  398.       ArcType := 5
  399.    ELSE IF (St = 'COM') OR (St = 'EXE') THEN
  400.       ArcType := -1
  401.    ELSE
  402.       ErrCode := 9999;
  403.  
  404.    Posn := 0;
  405.  
  406.    IF ErrCode = 0 THEN BEGIN
  407.       Assign(Handle, Archive);
  408.       Reset(Handle, 1);
  409.       ErrCode := IOResult;
  410.    END;
  411.    IF ErrCode = 0 THEN BEGIN
  412.       IF ArcType = -1 THEN BEGIN
  413.          BlockRead(Handle, Header.buf, 2, Chars);
  414.          Header.str[0] := CHR(Chars);
  415.          ErrCode := IOResult;
  416.          IF ErrCode = 0 THEN
  417.             IF Header.str <> 'MZ' THEN
  418.                ErrCode := 9999;
  419.          IF ErrCode = 0 THEN BEGIN
  420.             Seek(Handle, 1636);
  421.             ErrCode := IOResult;
  422.          END;
  423.          IF ErrCode = 0 THEN BEGIN
  424.             BlockRead(Handle, Header.buf, 8, Chars);
  425.             Header.str[0] := CHR(Chars);
  426.             ErrCode := IOResult;
  427.          END;
  428.          IF ErrCode = 0 THEN BEGIN
  429.             IF Copy(Header.str, 3, 3) = '-lh' THEN BEGIN
  430.                ArcType := 2;
  431.                Posn := 1636;
  432.                Seek(Handle, Posn);
  433.                ErrCode := IOResult;
  434.             END;
  435.          END;
  436.          IF (ErrCode = 0) AND (ArcType = -1) THEN BEGIN   { check for new ZIP }
  437.             Seek(Handle, 15770);
  438.             ErrCode := IOResult;
  439.             IF ErrCode = 0 THEN BEGIN
  440.                BlockRead(Handle, Header.buf, 4, Chars);
  441.                Header.str[0] := CHR(Chars);
  442.                ErrCode := IOResult;
  443.             END;
  444.             IF ErrCode = 0 THEN BEGIN
  445.                IF Copy(Header.str, 1, 4) = 'PK' + CHR(3) + CHR(4) THEN BEGIN
  446.                   ArcType := 3;
  447.                   Posn := 15770;
  448.                   Seek(Handle, Posn);
  449.                   ErrCode := IOResult;
  450.                END
  451.                ELSE
  452.                   ErrCode := 9999;
  453.             END;
  454.          END;
  455.          IF (ErrCode = 0) AND (ArcType = -1) THEN BEGIN   { check for old ZIP }
  456.             Seek(Handle, 12784);
  457.             ErrCode := IOResult;
  458.             IF ErrCode = 0 THEN BEGIN
  459.                BlockRead(Handle, Header.buf, 4, Chars);
  460.                Header.str[0] := CHR(Chars);
  461.                ErrCode := IOResult;
  462.             END;
  463.             IF ErrCode = 0 THEN BEGIN
  464.                IF Copy(Header.str, 1, 4) = 'PK' + CHR(3) + CHR(4) THEN BEGIN
  465.                   ArcType := 3;
  466.                   Posn := 12784;
  467.                   Seek(Handle, Posn);
  468.                   ErrCode := IOResult;
  469.                END
  470.                ELSE
  471.                   ErrCode := 9999;
  472.             END;
  473.          END;
  474.          IF (ErrCode = 0) AND (ArcType = -1) THEN BEGIN   { check for ARJ }
  475.             Seek(Handle, 14858);
  476.             BlockRead(Handle, Header.str, 2, Chars);
  477.             Header.str[0] := CHR(Chars);
  478.             IF Header.str = CHR($60) + CHR($EA) THEN BEGIN
  479.                ArcType := 5;
  480.                Posn := 14858;
  481.                Seek(Handle, Posn);
  482.             END;
  483.          END;
  484.          IF (ErrCode = 0) AND (ArcType = -1) THEN
  485.             ErrCode := 9999;
  486.       END;
  487.       IF ErrCode = 0 THEN BEGIN
  488.          BlockRead(Handle, Header.buf, 128, Chars);
  489.          Header.str[0] := CHR(Chars);
  490.          ErrCode := IOResult;
  491.       END;
  492.       CASE ArcType OF
  493.          1: IF (ORD(Header.str[1]) <> 26) OR (ORD(Header.str[2]) = 0) THEN
  494.                ErrCode := 9999;
  495.          2: IF Header.str[3] <> '-' THEN
  496.                ErrCode := 9999;
  497.          3: IF Copy(Header.str, 1, 4) <> 'PK' + CHR(3) + CHR(4) THEN
  498.                ErrCode := 9999;
  499.          4: IF Copy(Header.str, 21, 4) = CHR($DC) + CHR($A7) + CHR($C4) + CHR($FD) THEN BEGIN
  500.                Posn := CVL(Copy(Header.str, $19, 4));
  501.                Seek(Handle, Posn);
  502.                ErrCode := IOResult;
  503.                IF ErrCode = 0 THEN BEGIN
  504.                   BlockRead(Handle, Header.str, 128, Chars);
  505.                   Header.str[0] := CHR(Chars);
  506.                   ErrCode := IOResult;
  507.                END;
  508.             END
  509.             ELSE
  510.                ErrCode := 9999;
  511.          5: IF Copy(Header.str, 1, 2) <> CHR($60) + CHR($EA) THEN
  512.                ErrCode := 9999
  513.             ELSE BEGIN
  514.                Posn := LONGINT(CVI(Copy(Header.str, 3, 2))) + 10;
  515.                Seek(Handle, Posn);
  516.                ErrCode := IOResult;
  517.                IF ErrCode = 0 THEN BEGIN
  518.                   BlockRead(Handle, Header.buf, 128, Chars);
  519.                   Header.str[0] := CHR(Chars);
  520.                   ErrCode := IOResult;
  521.                END;
  522.             END;
  523.       END;
  524.       IF ErrCode = 0 THEN BEGIN
  525.          Seek(Handle, Posn);
  526.          ErrCode := IOResult;
  527.       END;
  528.       IF ErrCode = 0 THEN BEGIN
  529.          CurFileName := GetNameA;
  530.          IF Length(CurFileName) > 0 THEN
  531.             Found := MatchFile(PatternFileName, CurFileName)
  532.          ELSE
  533.             Found := FALSE;
  534.       END;
  535.       IF (ErrCode <> 0) OR NOT Found THEN
  536.          FindNextA(ErrCode);
  537.    END;
  538. END;
  539.  
  540.  
  541.  
  542. { ----------------------- initialization code --------------------------- }
  543. BEGIN
  544. END.
  545.